home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
cmplabel.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
12KB
|
264 lines
;;; CMPLABEL Exit manager.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(defvar *last-label* 0)
(defvar *exit*)
(defvar *unwind-exit*)
;;; *last-label* holds the label# of the last used label.
;;; *exit* holds an 'exit', which is
;;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
;;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-SHORT-FLOAT, or
;;; RETURN-OBJECT).
;;; *unwind-exit* holds a list consisting of:
;;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
;;; JUMP, BDS-BIND (each pushed for a single special binding), and
;;; cvar (which holds the bind stack pointer used to unbind).
(defmacro next-label () `(cons (incf *last-label*) nil))
(defmacro next-label* () `(cons (incf *last-label*) t))
(defmacro wt-label (label)
`(when (cdr ,label) (wt-nl1 "T" (car ,label) ":;")))
(defmacro wt-go (label)
`(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")))
(defun unwind-bds (bds-cvar bds-bind)
(when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");"))
(dotimes* (n bds-bind) (wt-nl "bds_unwind1;")))
(defun unwind-exit (loc &optional (jump-p nil)
&aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0))
(declare (fixnum bds-bind))
(when (and (eq loc 'fun-val)
(not (eq *value-to-go* 'return))
(not (eq *value-to-go* 'top)))
(wt-nl) (reset-top))
(cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true))
(set-jump-true loc (cadr *value-to-go*))
(when (eq loc t) (return-from unwind-exit)))
((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false))
(set-jump-false loc (cadr *value-to-go*))
(when (null loc) (return-from unwind-exit))))
(dolist* (ue *unwind-exit* (baboon))
(cond
((consp ue)
(cond ((eq ue *exit*)
(cond ((and (consp *value-to-go*)
(or (eq (car *value-to-go*) 'jump-true)
(eq (car *value-to-go*) 'jump-false)))
(unwind-bds bds-cvar bds-bind))
(t
(if (or bds-cvar (plusp bds-bind))
;;; Save the value if LOC may possibly refer
;;; to special binding.
(if (and (consp loc)
(or (and (eq (car loc) 'var)
(member (var-kind (cadr loc))
'(SPECIAL GLOBAL)))
(member (car loc)
'(SIMPLE-CALL INLINE
INLINE-COND INLINE-FIXNUM
INLINE-CHARACTER
INLINE-LONG-FLOAT
INLINE-SHORT-FLOAT))))
(cond ((and (consp *value-to-go*)
(eq (car *value-to-go*) 'vs))
(set-loc loc)
(unwind-bds bds-cvar bds-bind))
(t (let ((temp (list 'vs (vs-push))))
(let ((*value-to-go* temp))
(set-loc loc))
(unwind-bds bds-cvar bds-bind)
(set-loc temp))))
(progn (unwind-bds bds-cvar bds-bind)
(set-loc loc)))
(set-loc loc))))
(when jump-p (wt-nl) (wt-go *exit*))
(return))
(t (setq jump-p t))))
((numberp ue) (setq bds-cvar ue bds-bind 0))
((eq ue 'bds-bind) (incf bds-bind))
((eq ue 'return)
(when (eq *exit* 'return)
;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*.
(set-loc loc)
(unwind-bds bds-cvar bds-bind)
(wt-nl "return;")
(return))
;;; Never reached
)
((eq ue 'frame)
(when (and (consp loc)
(member (car loc)
'(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM
INLINE-CHARACTER INLINE-LONG-FLOAT
INLINE-SHORT-FLOAT)))
(cond ((and (consp *value-to-go*)
(eq (car *value-to-go*) 'vs))
(set-loc loc)
(setq loc *value-to-go*))
(t (let ((*value-to-go* (list 'vs (vs-push))))
(set-loc loc)
(setq loc *value-to-go*)))))
(wt-nl "frs_pop();"))
((eq ue 'tail-recursion-mark))
((eq ue 'jump) (setq jump-p t))
((eq ue 'return-fixnum)
(when (eq *exit* 'return-fixnum)
;;; *VALUE-TO-GO* must be RETURN-FIXNUM
(cond ((or bds-cvar (plusp bds-bind))
(cond ((fixnum-loc-p loc)
(let ((cvar (next-cvar)))
(wt-nl "{int V" cvar "= ")
(wt-fixnum-loc loc) (wt ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(V" cvar ")}")))
(t (let ((vs (vs-push)))
(wt-nl) (wt-vs vs) (wt "= " loc ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(fix(") (wt-vs vs) (wt "))")
))))
(t (wt-nl "VMR" *reservation-cmacro* "(")
(wt-fixnum-loc loc) (wt ")")))
(return)))
((eq ue 'return-character)
(when (eq *exit* 'return-character)
;;; *VALUE-TO-GO* must be RETURN-CHARACTER
(cond ((or bds-cvar (plusp bds-bind))
(cond ((character-loc-p loc)
(let ((cvar (next-cvar)))
(wt-nl "{unsigned char V" cvar "= ")
(wt-character-loc loc) (wt ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(V" cvar ")}")))
(t (let ((vs (vs-push)))
(wt-nl) (wt-vs vs) (wt "= " loc ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(char-code(") (wt-vs vs) (wt "))")
))))
(t (wt-nl "VMR" *reservation-cmacro* "(")
(wt-character-loc loc) (wt ")")))
(return)))
((eq ue 'return-long-float)
(when (eq *exit* 'return-long-float)
;;; *VALUE-TO-GO* must be RETURN-LONG-FLOAT
(cond ((or bds-cvar (plusp bds-bind))
(cond ((long-float-loc-p loc)
(let ((cvar (next-cvar)))
(wt-nl "{int V" cvar "= ")
(wt-long-float-loc loc) (wt ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(V" cvar ")}")))
(t (let ((vs (vs-push)))
(wt-nl) (wt-vs vs) (wt "= " loc ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(fix(") (wt-vs vs) (wt "))")
))))
(t (wt-nl "VMR" *reservation-cmacro* "(")
(wt-long-float-loc loc) (wt ")")))
(return)))
((eq ue 'return-short-float)
(when (eq *exit* 'return-short-float)
;;; *VALUE-TO-GO* must be RETURN-SHORT-FLOAT
(cond ((or bds-cvar (plusp bds-bind))
(cond ((short-float-loc-p loc)
(let ((cvar (next-cvar)))
(wt-nl "{int V" cvar "= ")
(wt-short-float-loc loc) (wt ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(V" cvar ")}")))
(t (let ((vs (vs-push)))
(wt-nl) (wt-vs vs) (wt "= " loc ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro*
"(fix(") (wt-vs vs) (wt "))")
))))
(t (wt-nl "VMR" *reservation-cmacro* "(")
(wt-short-float-loc loc) (wt ")")))
(return)))
((eq ue 'return-object)
(when (eq *exit* 'return-object)
;;; *VALUE-TO-GO* must be RETURN-OBJECT
(cond ((or bds-cvar (plusp bds-bind))
(let ((vs (vs-push)))
(wt-nl) (wt-vs vs) (wt "= " loc ";")
(unwind-bds bds-cvar bds-bind)
(wt-nl "VMR" *reservation-cmacro* "(")
(wt-vs vs) (wt ")")
))
(t (wt-nl "VMR" *reservation-cmacro* "(" loc ")")))
(return)))
(t (baboon))
;;; Never reached
))
)
(defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0))
(declare (fixnum bds-bind))
(dolist* (ue *unwind-exit* (baboon))
(cond
((consp ue)
(when (eq ue exit)
(unwind-bds bds-cvar bds-bind)
(return)))
((numberp ue) (setq bds-cvar ue bds-bind 0))
((eq ue 'bds-bind) (incf bds-bind))
((member ue '(return return-object return-fixnum return-character
return-long-float return-short-float))
(cond ((eq exit ue) (unwind-bds bds-cvar bds-bind)
(return))
(t (baboon)))
;;; Never reached
)
((eq ue 'frame) (wt-nl "frs_pop();"))
((eq ue 'tail-recursion-mark)
(cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind)
(return))
(t (baboon)))
;;; Never reached
)
((eq ue 'jump))
(t (baboon))
;;; Never reached
))
)
;;; Tail-recursion optimization for a function F is possible only if
;;; 1. the value of *DO-TAIL-RECURSION* is non-nil (this is default),
;;; 2. F receives only required parameters, and
;;; 3. no required parameter of F is enclosed in a closure.
;;;
;;; A recursive call (F e1 ... en) may be replaced by a loop only if
;;; 1. F is not declared as NOTINLINE,
;;; 2. n is equal to the number of required parameters of F,
;;; 3. the form is a normal function call (i.e. the arguments are
;;; pushed on the stack,
;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic
;;; binding (such as LET, LET*, PROGV),
;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame
;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are
;;; enclosed in a closure, and CATCH),
(defun tail-recursion-possible ()
(dolist* (ue *unwind-exit* (baboon))
(cond ((eq ue 'tail-recursion-mark) (return t))
((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame))
(return nil))
((or (consp ue) (eq ue 'jump)))
(t (baboon)))))